perm filename LINEW.F4[PIC,LCS] blob sn#632691 filedate 1982-01-09 generic text, type T, neo UTF8
	SUBROUTINE LINES(I)
  
	COMMON/FU/FUJ(512),JJX,RDIV,ADML/MEDGE/MC,MD,RMC,MMD
	COMMON/DRW/JDRW(2000)
	EQUIVALENCE(KNT,JDRW(1))
	COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
	1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
	DATA IFLIP/-1/,RDIV/.5/,FUJ(1)/99./
	CALL SWITCH
C REVERSE OR INVERT (IN 'SWITCH') HAPPEN BEFORE DISTORTION OR ROTATE.
	IF(FUJ(1).EQ.99)GO TO 31
	RX=JA*RMC+1
	IF(RX.GT.512.)RX=512.
	IF(ADML.GE.0)GO TO 32
	JB=JB+MMD*FUJ(IFIX(RX))
C  'CENTR' IS MULT FOR ADDING!  (CENTR 102 = MULT THE FUNC BY 2 AND ADD)
	GO TO 31
32	NY=JB-MMD
	JB=MMD+NY*FUJ(IFIX(RX))
31	IF(ROT.LE.1)GO TO 9
	RX=JA
	RY=JB
	AX=ATAN2(RY,RX)*57.29578
	HYP=SQRT(RX**2+RY**2)
	RT=ROT+AX
	JA=HYP*COSD(RT)
	JB=HYP*SIND(RT)
	GO TO 10
9	IF(ROT.GT.0)CALL EXCH(JA,JB)
10	JA=JA+JX
	JB=JB+JY
C  IF ROT.GE.0 ROTATE 90 DEG. TO LEFT
	M=JA
	N=JB
	IF(PLT)GO TO 1
6	M=M-JAR
	N=N-JBR
CC2	TYPE 20,M,N,JX,JY
20	FORMAT(4I6)
	IF(I.EQ.3)GO TO 3
	CALL RVECT(M,N)
5	JAR=JA
	JBR=JB
	RETURN
3	CALL RIVECT(M,N)
	GO TO 5

CC1	TYPE 20,M,N,JX,JY
1	IF(PLT.EQ.-2)GO TO 4
	CALL PLOT(M,N,I)
	RETURN
4	IFLIP=-IFLIP
	IF(I.EQ.3)GO TO 7
	IF(KNT.GE.200.OR.IFLIP)RETURN
	GO TO 70
7	IF(JDRW(KNT).GT.100000000)GO TO 71
70	KNT=KNT+1
71	M=M/8
	N=N/8
	IF(M.NE.KM)GO TO 56
	IF(IABS(N-KN).GT.1)GO TO 55
	IF(N.EQ.KN)GO TO 59
57	IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
	GO TO 58
56	IF(N.NE.KN)GO TO 55
	IF(IABS(M-KM).LE.1)GO TO 57
	GO TO 55
59	IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
	RETURN
55	IF(I.NE.3)GO TO 11
	KM=10000
	GO TO 8
11	IF(M-KM.NE.LM.OR.N-KN.NE.LN)GO TO 8
	IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
8	LN=N-KN
	LM=M-KM
	KM=M
	KN=N
58	M=(M-50)*10000
	N=N-50
	IF(M)M=10000000-M
	IF(N)N=1000-N
	IF(I.EQ.3)M=M+100000000
	JDRW(KNT)=M+N
	IF(JDRW(KNT).EQ.0)KNT=KNT-1
	END

	SUBROUTINE EXCH(J,K)
	I=J
	J=K
	K=I
	END

	SUBROUTINE JZERO
	COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
	1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
	JAR=0
	JBR=0
	END

	SUBROUTINE DSTORT(JPL)
	COMMON/MEDGE/MC,MD,RMC,MMD/FU/FUJ(512),JJX,RDIV,ADML
	MMD=(MD/JPL)*RDIV
	IF(ADML)MMD=RDIV*(MD/JPL)
C  'CENTR' IS MULT FOR ADDING!  (CENTR 102 = MULT THE FUNC BY 2 AND ADD)
	RMC=MC
	RMC=511./(RMC/JPL)
	END

	SUBROUTINE INVIS(MA,MB,MC,MD,N)
	DIMENSION LL(100)
	COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
	1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
	CALL JZERO
	NA=MA/3
	NB=MB/3
	NC=MC/3
	ND=MD/3
	IF(N.EQ.0)N=-1
	IF(N)CALL DPYSET(2,LL,100)
	N=1
	CALL JZERO
	CALL DPYBRT(2)
1	CALL AIVECT(-380,-200)
	JA=NA
	JB=NC
	CALL LINES(3)
	JB=NC
	JA=NB
	CALL LINES(2)
	JB=ND
	JA=NB
	CALL LINES(2)
	JA=NA
	JB=ND
	CALL LINES(2)
	JA=NA
	JB=NC
	CALL LINES(2)
	CALL JZERO
6683	CALL DPYOUT(2)
	END

	SUBROUTINE SWITCH
	COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
	1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
	IF(REV.NE.0)JA=JREV-JA
	IF(RINV.NE.0)JB=JINV-JB
	END

	SUBROUTINE DPFUN(JFU)
	COMMON/FU/FUJ(512),JJX,RDIV,ADML/DRW/LIST(2000)
13	IF(JFU.NE.' ')GO TO 19
	TYPE 14
14	FORMAT(' FUNC FILE NAME?  ',$)
15	FORMAT(8F)
83	FORMAT(A5)
	ACCEPT 83,JFU
	IF(JFU.NE.' ')GO TO 19
	FUJ(1)=99.
C  A BLANK DELETES FUNC ACTION.
	RETURN
19	REWIND 1
	CALL IFILE(1,JFU)
	DO 17 K=1,3
17	READ(1,18)A,B,B
18	FORMAT(3A5)
16	READ(1,15)A,B
	IF(B.NE.520.0)GO TO 16
	READ(1,15)FUJ
	CALL DPYSET(3,LIST,500)
	CALL ALINE(306,300,476,300)
	CALL ALINE(306,215,306,385)
CC	CALL AIVECT(0,0)
	KY=FUJ(1)*85.0+300.
	CALL AIVECT(306,KY)
	DO 32 K=2,512,3
	KY2=FUJ(K)*85.0+300.
	CALL RVECT(1,KY2-KY)
32	KY=KY2
	CALL DPYOUT(3)
	END
	SUBROUTINE DD
	COMMON/DRW/JDRW(2000)
3	REWIND 21
6	K=JDRW(1)+1
	
	IF(K.LE.201)GO TO 5
	JDRW(1)=200
	K=201
5	WRITE(21,120)K
120	FORMAT(' 9999  1 ',I4,' 0 0 0 0 0 0 0 0')
	J=7
	L=8
	DO 12 K=1,JDRW(1),8
	IF(K+J.LT.JDRW(1))GO TO 12
	J=JDRW(1)-K
	L=J+1
12	WRITE(21,11)L,(JDRW(N),N=K,K+J)
	CALL EXIT
11	FORMAT(' 9999',I3,8I10)
	END